#COMPILE EXE "iCalendar Generator.exe" #DIM ALL $VER = "0.1" '------------------------------------------------------------------------------ ' ** Includes ** '------------------------------------------------------------------------------ #INCLUDE ONCE "Win32Api.inc" #INCLUDE ONCE "inc\RTF.inc" #INCLUDE ONCE "inc\Julian.inc" '------------------------------------------------------------------------------ #RESOURCE "res\iCalendar Generator.pbr" '------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------ ' ** Constants ** '------------------------------------------------------------------------------ %IDC_LABEL1 = 1001 %IDC_LABEL2 = 1002 %IDC_LABEL3 = 1003 %IDC_L_YSTA = 1004 ' Label for Year-Start %IDC_L_YCNT = 1005 ' Label for Year-Count %IDC_UD_YSTA = 1006 ' Up-Down control for Year-Start %IDC_UD_YCNT = 1007 ' Up-Down control for Year-Count %IDC_T_YSTA = 1008 ' Textbox control for Year-Start %IDC_T_YCNT = 1009 ' Textbox control for Year-Count %IDC_BUTTON1 = 1010 %IDC_BUTTON2 = 1011 %IDC_TEXTBOX = 1012 '------------------------------------------------------------------------------ ' ** Globals ** '------------------------------------------------------------------------------ GLOBAL evok AS LONG GLOBAL evko AS LONG GLOBAL icsf AS STRING GLOBAL erli AS STRING '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** Main Application Entry Point ** '------------------------------------------------------------------------------ FUNCTION PBMAIN() LoadLibrary("RICHED32.DLL") ShowMain %HWND_DESKTOP END FUNCTION '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** Functions / Subs ** '------------------------------------------------------------------------------ MACRO CFGFILE = EXE.PATH$ + EXE.NAME$ + ".cfg" '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ FUNCTION NowUTCstamp() AS STRING LOCAL e, r AS STRING e = DATE$ r = RIGHT$(e,4) + LEFT$(e,2) + MID$(e,4,2) + "T" e = TIME$ r += LEFT$(e,2) + MID$(e,4,2) + RIGHT$(e,2) + "Z" FUNCTION = r END FUNCTION '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ FUNCTION UID() AS STRING LOCAL e, r AS STRING LOCAL i AS LONG e = GUID$ FOR i = 1 TO LEN(e) r += HEX$(ASC(e,i), 2) IF LEN(r) = 23 OR LEN(r) = 18 OR LEN(r) = 13 OR LEN(r) = 8 THEN r += "-" NEXT FUNCTION = LCASE$(r) END FUNCTION '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ FUNCTION IcsDate(BYVAL y AS LONG, BYVAL m AS LONG, BYVAL d AS LONG) AS STRING LOCAL e, r AS STRING e = TRIM$(STR$(y)) : WHILE LEN(e) < 4 : e = "0" + e : WEND r = e e = TRIM$(STR$(m)) : IF LEN(e) < 2 THEN e = "0" + e r += e e = TRIM$(STR$(d)) : IF LEN(e) < 2 THEN e = "0" + e r += e FUNCTION = r END FUNCTION '------------------------------------------------------------------------------ '------------------------------------------------------------------------------------------------- FUNCTION Exist(BYVAL fileOrFolder AS STRING) AS LONG LOCAL Dummy& Dummy& = GETATTR(fileOrFolder) FUNCTION = (ERRCLEAR = 0) END FUNCTION '------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------- FUNCTION Get_Resource(BYVAL rid AS LONG) AS STRING LOCAL L1, L2 AS LONG LOCAL D1, D2 AS DWORD L1 = FindResource (GetModuleHandle(""), "#"+FORMAT$(rid), BYVAL %RT_RCDATA) D2 = SizeofResource(GetModuleHandle(""), L1) L2 = LoadResource (GetModuleHandle(""), L1) D1 = LockResource (L2) FUNCTION = PEEK$(D1,D2) END FUNCTION '------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------- SUB DumpStandardCfgFile() LOCAL ff AS LONG KILL CFGFILE ff = FREEFILE OPEN CFGFILE FOR BINARY AS #ff PUT$ #ff, Get_Resource(10) ' iCalendar Generator.cfg CLOSE #ff END SUB '------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------- SUB GenerateIcs(BYVAL ysta AS LONG, BYVAL ycnt AS LONG) LOCAL ffi AS LONG LOCAL ffo AS LONG LOCAL lin AS LONG LOCAL y,m,d AS LONG LOCAL i,j,k AS LONG LOCAL em,ed AS LONG ' Easter month/day LOCAL e,s AS STRING erli = "" ' Reset lines in error evok = 0 evko = 0 ffo = FREEFILE KILL icsf OPEN icsf FOR OUTPUT ACCESS WRITE LOCK READ WRITE AS #ffo PRINT #ffo, "BEGIN:VCALENDAR" PRINT #ffo, "PRODID:"+EXE.NAME$+" - http://mougino.free.fr" PRINT #ffo, "VERSION:2.0" PRINT #ffo, "" FOR y = ysta TO ysta + ycnt - 1 ' Calculate Easter Date em = 3 : ed = EasterDate(y) IF ed > 31 THEN ' Easter in April em = 4 : ed -= 31 END IF ' Open Script File for Input ffi = FREEFILE OPEN CFGFILE FOR INPUT ACCESS READ LOCK SHARED AS #ffi lin = 0 DO LINE INPUT #ffi, e : e = TRIM$(e) : INCR lin IF e = "" OR LEFT$(e, 1) = "#" THEN ITERATE LOOP ' ignore comments & empty lines i = INSTR(e,"#") IF i > 0 THEN e = TRIM$(LEFT$(e,i-1)) ' remove inline comments i = INSTR(e,"=") IF i = 0 THEN GOSUB LineInError : ITERATE LOOP ' line must contain an '=' s = UCASE$(TRIM$(LEFT$(e,i-1))) e = TRIM$(MID$(e,i+1)) IF INSTR(s,"/") > 0 THEN ' fixed date "dd/mm" i = INSTR(s,"/") d = VAL(LEFT$(s,i-1)) m = VAL( MID$(s,i+1)) IF d=0 OR m=0 THEN GOSUB LineInError ELSE GOSUB WriteIcsEvent END IF ELSEIF INSTR(s,"E+") = 1 THEN ' date based on Easter (after) i = VAL(MID$(s,3)) j = Julian(y, em, ed) + i s = Julian2Date(j) y = VAL(LEFT$(s,4)) m = VAL(MID$(s,5,2)) d = VAL(RIGHT$(s,2)) GOSUB WriteIcsEvent ELSEIF INSTR(s,"E-") = 1 THEN ' date based on Easter (before) i = VAL(MID$(s,3)) j = Julian(y, em, ed) - i s = Julian2Date(j) y = VAL(LEFT$(s,4)) m = VAL(MID$(s,5,2)) d = VAL(RIGHT$(s,2)) GOSUB WriteIcsEvent ELSE ' date neither fixed, GOSUB LineInError ' nor based on Easter END IF LOOP UNTIL EOF(#ffi) CLOSE #ffi NEXT PRINT #ffo, "END:VCALENDAR" CLOSE #ffo erli = RTRIM$(erli, ";") EXIT SUB LineInError: '----------- erli += TRIM$(STR$(lin))+";" INCR evko RETURN WriteIcsEvent: '------------- PRINT #ffo, "BEGIN:VEVENT" PRINT #ffo, "DTSTAMP:" + NowUTCstamp() PRINT #ffo, "DTSTART;VALUE=DATE:" + IcsDate(y,m,d) PRINT #ffo, "SUMMARY:" + e PRINT #ffo, "TRANSP:OPAQUE" PRINT #ffo, "X-MICROSOFT-CDO-BUSYSTATUS:OOF" PRINT #ffo, "UID:" + UID() + "@mougino.free.fr" PRINT #ffo, "END:VEVENT" PRINT #ffo, "" INCR evok RETURN END SUB '------------------------------------------------------------------------------------------------- '------------------------------------------------------------------------------------------------- SUB Fill_RichEdit (hD AS DWORD, CtlId AS LONG) LOCAL richtext AS STRING richtext = "[black][c]" richtext += "[h:lime][font:a,11][b]Outlook instructions[/b][/h][eol][l]" richtext += "[font:a,9][black][l][eol]" richtext += "In Outlook, while in the Calendar view, click [blue]File [black]> [blue]Open & Export " richtext += "[black]then [blue]Import/Export [black] and finally choose ""[blue]Import an iCalendar " richtext += "(.ics) or vCalendar file (.vcs)[black]"" then click Next.[eol]" richtext += "[eol]" richtext += "Locate the iCalendar file (.ics) that you generated with this program, and when asked " richtext += "if you want to open this calendar as a new calendar or import its items into your " richtext += "calendar, choose ""[blue]Import[black]""." richtext += "[eop]" richtext += "[eol]" richtext += "[c][b][maroon]C[red]r[fuschia]e[purple]a[blue]t[teal]e[green]d [lime]b[grey]y [maroon]m[red]o[fuschia]u[purple]g[blue]i[teal]n[green]o[lime]" richtext += " - http://mougino.free.fr[/b]" richtext += "[eol]" richtext += "[eop]" RTF_SET hD, CtlId, richtext END SUB '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** CallBacks ** '------------------------------------------------------------------------------ MACRO Y_LAST = IIF$(ycnt>1, "-"+TRIM$(STR$(ysta+ycnt-1)), "") '------------------------------------------------------------------------------ CALLBACK FUNCTION ProcMain() LOCAL t AS STRING SELECT CASE AS LONG CB.MSG CASE %WM_INITDIALOG ' Initialization handler SendMessage GetDlgItem(CB.HNDL,%IDC_TEXTBOX), %EM_setBkgndColor, _ %False, GetSysColor(%COLOR_MENU) IF NOT EXIST(CFGFILE) THEN DumpStandardCfgFile() END IF CASE %WM_NOTIFY ' Special RichEdit notifications IF CB.NMID = %IDC_TEXTBOX AND CB.NMCODE = %EN_LINK THEN RTF_hyperlink (CB.HNDL, %IDC_TEXTBOX, CB.LPARAM) END IF CASE %WM_COMMAND ' Process control messages SELECT CASE AS LONG CB.CTL CASE %IDC_T_YSTA ' Year Start UpDown/TxtBox IF CB.CTLMSG = %EN_CHANGE THEN CONTROL GET TEXT CB.HNDL, %IDC_T_YSTA TO t t = REMOVE$(t, CHR$(160)) CONTROL SET TEXT CB.HNDL, %IDC_L_YSTA, t END IF CASE %IDC_T_YCNT ' Year Count UpDown/TxtBox IF CB.CTLMSG = %EN_CHANGE THEN CONTROL GET TEXT CB.HNDL, %IDC_T_YCNT TO t t = REMOVE$(t, CHR$(160)) CONTROL SET TEXT CB.HNDL, %IDC_L_YCNT, t END IF CASE %IDC_BUTTON1 ' View/change holiday script IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN ShellExecute 0, "open", CFGFILE, "", "", %SW_SHOW END IF CASE %IDC_BUTTON2 ' GENERATE ICS LOCAL ysta, ycnt AS LONG IF CB.CTLMSG = %BN_CLICKED OR CB.CTLMSG = 1 THEN CONTROL GET TEXT CB.HNDL, %IDC_L_YSTA TO t : ysta = VAL(t) CONTROL GET TEXT CB.HNDL, %IDC_L_YCNT TO t : ycnt = VAL(t) DISPLAY SAVEFILE CB.HNDL, -50, -50, EXE.NAME$, EXE.PATH$, _ "iCalendar" + CHR$(0) + "*.ics" + CHR$(0), _ "Public Holidays "+TRIM$(STR$(ysta))+Y_LAST+".ics", _ "ics", %OFN_PATHMUSTEXIST OR %OFN_OVERWRITEPROMPT TO t IF t = "" THEN EXIT FUNCTION ' Cancelled by user icsf = t ' Global string 'ICS file' GenerateIcs ysta, ycnt t = "iCalendar successfully generated for the year" + IIF$(ycnt>1,"s","") t += " " + TRIM$(STR$(ysta)) + Y_LAST + " :" + $CR + $CR t += "- " + TRIM$(STR$(evok)) + " event(s) generated" + $CR + $CR t += "- " + TRIM$(STR$(evko)) + " error(s)" IF erli <> "" THEN t += " at script line"+IIF$(INSTR(erli,";")>0,"s "," ")+erli END IF MessageBox CB.HNDL, (t), EXE.NAME$, %MB_ICONINFORMATION END IF END SELECT END SELECT END FUNCTION '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' ** Dialogs ** '------------------------------------------------------------------------------ %UDS_WRAP = &H0001 %UDS_SETBUDDYINT = &H0002 %UDS_ARROWKEYS = &H0020 %UDM_SETRANGE = %WM_USER + 101 %UDM_SETBUDDY = %WM_USER + 105 '------------------------------------------------------------------------------ FUNCTION ShowMain(BYVAL hParent AS DWORD) AS LONG LOCAL hDlg AS DWORD LOCAL hIco AS DWORD LOCAL lRes AS LONG LOCAL year AS STRING year = DATE$ : year = RIGHT$(year, 4) DIALOG NEW PIXELS, hParent, EXE.NAME$+$SPC+$VER, 514, 250, 355, 328, _ %WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_CAPTION OR _ %WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _ %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, _ %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _ %WS_EX_RIGHTSCROLLBAR, TO hDlg hIco = ExtractIcon(GetModuleHandle(""), "imageres.dll", 272) SetClassLong(hDlg, %GCL_HICONSM, hIco) SetClassLong(hDlg, %GCL_HICON, hIco) CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "Start at year :", 16, 16, 72, 16 CONTROL ADD LABEL, hDlg, %IDC_L_YSTA, year, 88, 14, 40, 20, %WS_CHILD _ OR %WS_VISIBLE OR %WS_BORDER OR %SS_CENTER OR %SS_CENTERIMAGE, _ %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL SET COLOR hDlg, %IDC_L_YSTA, -1, %WHITE CONTROL ADD "msctls_updown32", hDlg, %IDC_UD_YSTA, "", 88+40+2, 12, 34, 24, _ %WS_CHILD OR %WS_VISIBLE OR %UDS_WRAP OR %UDS_SETBUDDYINT OR %UDS_ARROWKEYS CONTROL ADD TEXTBOX, hDlg, %IDC_T_YSTA, year, -10, -10, 1, 1 CONTROL SEND hDlg, %IDC_UD_YSTA, %UDM_SETBUDDY, GetDlgItem(hDlg, %IDC_T_YSTA), 0& CONTROL SEND hDlg, %IDC_UD_YSTA, %UDM_SETRANGE, 0&, MAKLNG (9999,0) CONTROL ADD LABEL, hDlg, %IDC_LABEL2, "and generate for", 152, 16, 88, 16, %SS_CENTER CONTROL ADD LABEL, hDlg, %IDC_L_YCNT, "1", 240, 14, 32, 20, %WS_CHILD _ OR %WS_VISIBLE OR %WS_BORDER OR %SS_CENTER OR %SS_CENTERIMAGE, _ %WS_EX_LEFT OR %WS_EX_LTRREADING CONTROL SET COLOR hDlg, %IDC_L_YCNT, -1, %WHITE CONTROL ADD "msctls_updown32", hDlg, %IDC_UD_YCNT, "", 240+32+2, 12, 34, 24, _ %WS_CHILD OR %WS_VISIBLE OR %UDS_WRAP OR %UDS_SETBUDDYINT OR %UDS_ARROWKEYS CONTROL ADD TEXTBOX, hDlg, %IDC_T_YCNT, "1", -10, -10, 1, 1 CONTROL SEND hDlg, %IDC_UD_YCNT, %UDM_SETBUDDY, GetDlgItem(hDlg, %IDC_T_YCNT), 0& CONTROL SEND hDlg, %IDC_UD_YCNT, %UDM_SETRANGE, 0&, MAKLNG (99,1) CONTROL ADD LABEL, hDlg, %IDC_LABEL3, "year(s).", 304, 16, 48, 16 CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "View/change script", 8, 48, 140, 24 CONTROL ADD BUTTON, hDlg, %IDC_BUTTON2, "GENERATE ICS", 192, 46, 152, 28 CONTROL ADD "RichEdit", hDlg, %IDC_TEXTBOX, "", 8, 88, 336, 230, _ %WS_CHILD OR %WS_VISIBLE OR %ES_MULTILINE OR %ES_READONLY _ OR %WS_VSCROLL Fill_RichEdit (hDlg, %IDC_TEXTBOX) DIALOG SHOW MODAL hDlg, CALL ProcMain TO lRes FUNCTION = lRes END FUNCTION '------------------------------------------------------------------------------